PD ROM 1/PD ROM Volume I - Macintosh Software from BMUG (1988).iso/Programming/Complete Applications/Telecom/MT Special 3/IBM WWIV/DLOADS.PAS

Pascal/Delphi Source File | 1987-01-14 | 31.5 KB | 1,162 lines | [TEXT/ttxt]

Program dloads;

                      {*****************************}
                      {Copyright (c) 1986 Wayne Bell}
                      {*****************************}

{$V-} {$C-}
TYPE j=array[1..8] of string[14];

CONST strlen=160;
      comnum=1;
      maxbaud=1200;
      maxusers=300;
      dsaves : Integer = 0;
      buffer_Max    = 5120;
      comptyp:j=('IBM','APPLE','TRS-80','Z-80 CP/M','COMMODORE','ATARI',
                 'DUMB TERMINAL','OTHER');

TYPE str=string[strlen];
     restrictions=(rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,
                   rpost,remail,rvoting,rmsg);
     acrq='@'..'G';
     newtyp=(rp,lt,rm);
     deflts=(spcsr,onekey,wordwrap,pause);
     anontyp=(no,yes,forced,dearabby);
     ansttype=(postn,emailn,pana,sanm,cosysop,lcosysop);
     opts=(alert,smw,nomail);
     slr=record
           ttime:byte;
           mallowed:integer;
           emails,posts:byte;
           anst:set of ansttype;
         end;
     messages=record
                ltr:char;
                number:integer;
                ext:byte;
              end;
     smalrec=record
               name:string[25];
               number:integer;
             end;
     userrec=record
               name:string[25];
               realname:string[14];
               deleted:boolean;
               pw:string[8];
               ph:string[12];
               waiting:byte;
               laston:string[10];
               loggedon:integer;
               msgpost:integer;
               emailsent:integer;
               feedback:integer;
               linelen:byte;
               pagelen:byte;
               defaults:set of deflts;
               ontoday:byte;
               illegal:byte;
               cursor:string[10];
               sl:byte;
               ac:set of restrictions;
               ar:set of acrq;
               qscan:array[1..19] of messages;
               qscn:array[1..19] of boolean;
               macro:array[1..2] of string[79];
               comptype:byte;
               option:set of opts;
               vote:array[1..9] of byte;
               sbn:byte;
               dsl:byte;
               uploads,downloads:integer;
               uk,dk:integer;
             end;
      boardrec=record
                 name:string[25];
                 filename:string[12];
                 sl:byte;
                 maxmsgs:byte;
                 pw:string[10];
                 anonymous:anontyp;
                 ar:acrq;
                 key:char;
               end;
      msgstat=(validated,unvalidated,deleted);
      messagerec=record
                   title:string[30];
                   messagestat:msgstat;
                   message:messages;
                   owner:integer;
                   date:integer;
                   mage:byte;
                 end;
      systatrec=record
                  boardpw:string[8];
                  sysoppw:string[8];
                  hmsg:messages;
                  users:integer;
                  lastdate:string[8];
                  callernum:integer;
                  activetoday:integer;
                  callstoday:integer;
                  msgposttoday:integer;
                  emailtoday:integer;
                  fbacktoday:integer;
                  uptoday:integer;
                  closedsystem:boolean;
                end;
      blk=array[1..255] of byte;
      mailrec=record
                title:string[30];
                from,destin:integer;
                msg:messages;
                date:integer;
                mage:byte;
              end;
      gft=record
            num:integer;
            title:string[40];
            filen:string[12];
          end;
      charfil=text;
      smr=record
            msg:str;
            destin:integer;
          end;
      vdatar=record
               question:string[79];
               numa:integer;
               answ:array[0..9] of record
                      ans:string[25];
                      numres:integer;
                    end;
             end;
      regs=record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
      ulrec=record
              name:string[25];
              filename:string[12];
              password:string[10];
              dsl:byte;
              maxfiles:integer;
            end;
      ulfrec=record
               filename:string[12];
               description:string[60];
               res:array[1..17] of byte;
               ft:array[1..3] of byte;
               blocks:integer;
               owner:integer;
               date:string[8];
               daten:integer;
             end;

var sf:file of smalrec;
    uf:file of userrec;
    bf:file of boardrec;
    mf:file of messagerec;
    mailfile:file of mailrec;
    sysopf:charfil;
    slf:file of slr;
    seclev:array[0..255] of slr;
    systatf:file of systatrec;
    systat:systatrec;
    sr:smalrec;
    thisline,chatr,buf,spd,irt,lastname,ll,cursor,i:str;
    thisuser,user:userrec;
    boards:array[1..19] of boardrec;
    fw,extramsgs,mread,board,numboards,t,usernum:integer;
    pap,lil,realsl,ftoday,ptoday,etoday:integer;
    c,ID:char;
    hungup,useron,next,chatcall,expert,doneday,echo,hangup,incom,outcom:boolean;
    extratime,timeon:real;
    macok,lan,enddayf,ch,quit:boolean;
    buffer:Array[0..buffer_Max] of Char;
    comport,base:Integer;
    Async_Irq:Integer;
    buffer_Head,buffer_tail,buffer_newtail:Integer;
    smf:file of smr;
    srl:array[0..maxusers] of smalrec;
    vqu:array[1..9] of boolean;
    ret:byte absolute cseg:$0080;
    ldate1:integer;
    maxspd:integer;
    cmd:char;
    help:array[1..25000] of char;
    helpi:array['0'..'^'] of integer;
    helpl:char;
    ihelp:boolean;
    cf:text; cfo,okt:boolean;
    ulf:file of ulrec;
    uboards:array[0..19] of ulrec;
    ulff:file of ulfrec;
    crc,culb,maxulb:integer;
    sortbd,doneft:boolean;
    ldate:str;
    ymodem,ucrc,bnp:boolean;
    chksum:byte;
    lrn:integer;
    lfn:str;
    ft:byte;

label reent;

{$I COMMON.PAS}

procedure printfile(fn:str);
var fil:text;
    i:str;
    abort,next:boolean;
begin
 if not hangup then begin
  assign(fil,fn);
  {$I-} reset(fil); {$I+}
  if ioresult<>0 then print('File not found.') else begin
    abort:=false;
    while not eof(fil) and (not abort) and (not hangup) do begin
      readln(fil,i);
      if i[length(i)]<>#1 then i:=i+#1;
      printa(i,abort,next);
    end;
    close(fil);
  end;
  nl;nl;
 end;
end;

function tcheck(s:real; i:integer):boolean;
var r:real;
begin
  r:=timer;
  if r<s then r:=r+86400.0;
  if trunc(r-s)>i then tcheck:=false else tcheck:=true;
end;

function tchk(s:real; i:real):boolean;
var r:real;
begin
  r:=timer;
  if r<s then r:=r+86400.0;
  if (r-s)>i then tchk:=false else tchk:=true;
end;

{$I DLP1.PAS}

procedure i1;
begin
  assign(ulf,'gfiles\uploads.dat');
  reset(ulf); maxulb:=-1;
  while not eof(ulf) do begin maxulb:=maxulb+1; read(ulf,uboards[maxulb]); end;
  close(ulf);
  culb:=1;
  ldate:=thisuser.laston;
end;

function exist(fn:str):boolean;
var f:file;
begin
  assign(f,fn);
  {$I-} reset(f); {$I+}
  if ioresult=0 then begin close(f); exist:=true end else exist:=false;
end;

function align(fn:str):str;
var f,e,t:str; c,c1:integer;
begin
  c:=pos('.',fn);
  if c=0 then begin
    f:=fn; e:='   ';
  end else begin
    f:=copy(fn,1,c-1); e:=copy(fn,c+1,3);
  end;
  while length(f)<8 do f:=f+' ';
  while length(e)<3 do e:=e+' ';
  if length(f)>8 then f:=copy(f,1,8);
  if length(e)>3 then e:=copy(e,1,3);
  c:=pos('*',f); if c<>0 then for c1:=c to 8 do f[c1]:='?';
  c:=pos('*',e); if c<>0 then for c1:=c to 3 do e[c1]:='?';
  c:=pos(' ',f); if c<>0 then for c1:=c to 8 do f[c1]:=' ';
  c:=pos(' ',e); if c<>0 then for c1:=c to 3 do e[c1]:=' ';
  align:=f+'.'+e;
end;

function fit(f1,f2:str):boolean;
var tf:boolean; c:integer;
begin
  tf:=true;
  for c:=1 to 12 do
    if (f1[c]<>f2[c]) and (f1[c]<>'?') then tf:=false;
  fit:=tf;
end;

procedure iscan(var pl:integer);
var f:ulfrec;
begin
  assign(ulff,'gfiles\'+uboards[culb].filename);
  {$I-} reset(ulff); {$I+}
  if ioresult<>0 then begin
    rewrite(ulff);
    f.blocks:=0;
    write(ulff,f);
  end;
  seek(ulff,0);
  read(ulff,f);
  pl:=f.blocks;
  bnp:=false;
end;

procedure recno(fn:str; var pl,rn:integer);
var c:integer;
    f:ulfrec;
begin
  fn:=align(fn);
  iscan(pl); rn:=0; c:=1;
  while (c<=pl) and (rn=0) do begin
    seek(ulff,c); read(ulff,f);
    if fit(fn,align(f.filename)) then rn:=c;
    c:=c+1;
  end;
  lrn:=rn;
  lfn:=fn;
end;

procedure nrecno(fn:str; var pl,rn:integer);
var c:integer;
    f:ulfrec;
begin
  fn:=align(fn);
  if fn=lfn then begin
    if (lrn<pl) and (lrn>0) then begin
      c:=lrn+1; rn:=0;
      while (c<=pl) and (rn=0) do begin
        seek(ulff,c); read(ulff,f);
        if fit(fn,align(f.filename)) then rn:=c;
        c:=c+1;
      end;
      lrn:=rn;
    end else rn:=0;
  end else rn:=0;
end;

procedure arcl(fn:str; var abort:boolean);
type ei=record l,h:integer; end;
     archead=record
               name:array[1..13] of char;
               size:ei;
               date,time,crc:integer;
               len:ei;
             end;
var f:file; b:byte;
    head:archead;
    done,next:boolean;

  function valueei(x:ei):real;
  var r:real; tf:boolean;
  begin
    if x.h>=0 then begin r:=int(x.h)*65536.0; tf:=true; end else
      begin tf:=false; if x.h=$8000 then r:=65536.0*65536.0 else
        r:=int(-x.h)*65536.0; end;
    if x.l>=0 then r:=r+int(x.l)
    else if x.l=$8000 then r:=r+32760.0
    else r:=r+65536.0+x.l;
    if tf then valueei:=r else valueei:=-r;
  end;

  procedure pfn;
  var i,i1:str; try:byte;
  begin
    b:=0; try:=0;
    while not eof(f) and (b<>26) and (try<5) do begin
      blockread(f,b,1);
      try:=try+1;
    end;
    if try>=5 then longseek(f,filesize(f)-2.0);
    if longfilepos(f)+27<longfilesize(f) then begin
      blockread(f,b,1);
      if b<>0 then begin
          if b=1 then begin
          blockread(f,head,sizeof(head)-sizeof(ei));
          head.len:=head.size;
        end else blockread(f,head,sizeof(head));
        i:=''; b:=1;
        while (head.name[b]<>#0) and (b<=13) do begin
          i:=i+head.name[b];
          b:=b+1;
        end;
        i:=align(i)+' ';
        i1:=cstrr(valueei(head.len));
        while length(i1)<7 do i1:=' '+i1;
        i:=i+i1;
        printacr(i,abort,next);
      end else done:=true;
      longseek(f,longfilepos(f)+valueei(head.size));
    end;
  end;

begin
  assign(f,fn);
  reset(f,1); done:=false;
  while (longfilepos(f)+27.0<longfilesize(f)) and not (abort or done) do
    pfn;
  close(f);
end;

procedure lbrl(fn:str; var abort:boolean);
var f:file;
    c,n,n1:integer;
    x:record
        st:byte;
        name:array[1..8] of char;
        ext:array[1..3] of char;
        index,len:integer;
        fil:array[1..16] of byte;
      end;
    next:boolean;
    i,i1:str;

begin
  assign(f,fn);
  reset(f,32);
  blockread(f,x,1);
  c:=x.len*4-1;
  for n:=1 to c do begin
    blockread(f,x,1); i:='';
    if (x.st=0) and not abort then begin
      for n1:=1 to 8 do i:=i+x.name[n1];
      i:=i+'.';
      for n1:=1 to 3 do i:=i+x.ext[n1];
      i:=align(i)+' ';
      i1:=cstrr(x.len*128.0);
      while length(i1)<7 do i1:=' '+i1;
      i:=i+i1;
      printacr(i,abort,next);
    end;
  end;
  close(f);
end;

procedure lfi(fn:str; var abort:boolean);
var next:boolean; i1,i2:str;
begin
  if exist('dloads\'+fn) and (not abort) then
    if (pos('.ARC',fn)<>0) or (pos('.LBR',fn)<>0) then begin
      nl;
      i1:=align(fn); i2:=''; while length(i1)>length(i2) do i2:=i2+'-';
      printacr(i1,abort,next);
      printacr(i2,abort,next);
      nl;
      if not abort then begin
        if pos('.ARC',fn)<>0 then arcl('dloads\'+fn,abort);
        if pos('.LBR',fn)<>0 then lbrl('dloads\'+fn,abort);
      end;
      nl;
    end;
end;

procedure lfin(rn:integer; var abort:boolean);
var f:ulfrec;
begin
  seek(ulff,rn); read(ulff,f); lfi(f.filename,abort);
end;

procedure lfii;
var fn:str; pl,rn:integer; abort:boolean;
begin
  helpl:='[';
  nl; print('Enter file to list interior files of');
  prompt(': '); input(fn,12);
  recno(fn,pl,rn);
  abort:=false;
  if rn=0 then print('File not found.') else begin
    while (rn<>0) and (not abort) do begin
      lfin(rn,abort);
      nrecno(fn,pl,rn);
    end;
  end;
  close(ulff);
end;

procedure return;
var f:file;
begin
  assign(f,'bbs.com');
  print('Returning to BBS...');
  remove_port;
  if hangup then term_ready(false);
  execute(f);
end;


procedure pbn(var abort:boolean);
var i,i1:str; next:boolean;
begin
  if not bnp then begin
    nl;
    i:=uboards[culb].name+' #'+cstr(culb);
    i1:='---'; while length(i1)<length(i) do i1:=i1+'-';
    nl; nl;
    printacr(i,abort,next);
    printacr(i1,abort,next);
    nl;
  end;
  bnp:=true;
end;


function uc(s:str):str;
var x:str; i:integer;
begin
  x:=s;
  for i:=1 to length(s) do
    x[i]:=upcase(x[i]);
  uc:=x;
end;

procedure dlx(f1:ulfrec; var abort:boolean);
var inte,pl,c:integer; ok,tl:boolean; u:userrec; rl:real; i,ii:str;
begin
    nl; nl;
    print('Filename: "'+align(f1.filename)+'"');
    print('Desc.   : '+f1.description);
    print('# blocks: '+cstr(f1.blocks)+'-'+cstr((f1.blocks+7)div 8));
    inte:=value(spd); if inte=0 then inte:=1200;
    rl:=1620.0*f1.blocks/inte;
    if rl>32767.0 then rl:=32000; if rl<0.0 then rl:=0;
    inte:=trunc(rl);
    i:=cstr(inte div 3600)+':'; ii:=cstr((inte mod 3600) div 60);
    if length(ii)=1 then ii:='0'+ii; i:=i+ii+':';
    ii:=cstr(inte mod 60); if length(ii)=1 then ii:='0'+ii;
    i:=i+ii; print('apx time: '+i);
    reset(uf); seek(uf,f1.owner); read(uf,u); close(uf);
    print('U/L by  : '+u.name+' #'+cstr(f1.owner));
    print('U/L on  : '+f1.date);
    ft:=255; if (f1.ft[1]=$81) and (f1.ft[2]=$f5) then ft:=f1.ft[3];
    if ft<>255 then print('File typ: '+cstr(ft));
    if timer<timeon then timeon:=timeon-24.0*60*60;
    tl:=((seclev[thisuser.sl].ttime*60+extratime+timeon-timer-rl)>0);
    if tl or (copy(f1.filename,1,4)='WWIV') then begin
      if exist('dloads\'+f1.filename) then
        send1('dloads\'+f1.filename,ok,abort)
      else print('File isn''t really there!');
    end else print('Not enough time left to D/L');
end;

procedure dl(fn:str);
var pl,rn:integer; f:ulfrec; abort:boolean;
begin
  recno(fn,pl,rn); abort:=false;
  if rn=0 then print('File not found.') else begin
    while (rn<>0) and (not abort) do begin
      seek(ulff,rn); read(ulff,f); dlx(f,abort);
      nrecno(fn,pl,rn);
    end;
  end;
  close(ulff);
end;

procedure dl1(n:integer);
var f1:ulfrec; abort:boolean;
begin
  nl; nl;
  seek(ulff,n); read(ulff,f1);
  dlx(f1,abort);
  nl;
end;


procedure ul(fn:str);
var x,pl,c,cc,ob,np:integer; f,f1:ulfrec; uls,ok:boolean; fi:file of byte;
begin
  uls:=incom;
  ob:=culb;
  ok:=true; fn:=align(fn);
  if (fn[1]=' ') or (fn[10]=' ') then ok:=false;
  for x:=1 to length(fn) do
    if not (fn[x] in ['0'..'9','A'..'Z','.',' ']) then ok:=false;
  np:=0; for x:=1 to length(fn) do if fn[x]='.' then np:=np+1;
  if np<>1 then ok:=false;
  if ok then
    if incom then
      if exist('dloads\'+fn) then
        if cs then begin
          print('There already is one.');
          prompt('Do it anyways? ');
          ok:=yn;
          uls:=false;
        end else
          ok:=false
      else
        ok:=true
    else
      ok:=exist('dloads\'+fn)
  else print('Illegal filename.');
  if (not incom) then
    if ok then print('Am using the file in dloads\')
    else begin print('To put in a file from keyboard, it must already be');
               print('present in the dloads\ directory.'); end;
  nl; nl;
  if ok and incom and uls then begin
    assign(fi,'dloads\'+fn); {$I-} rewrite(fi); {$I+}
    if ioresult<>0 then begin
      {$I-} close(fi); {$I+} cc:=ioresult;
      ok:=false;
    end else begin close(fi); erase(fi); end;
  end;
  if not ok then print('Can''t use that filename, sorry.') else begin
    iscan(pl);
    if pl>=uboards[culb].maxfiles then print('This board is full.') else begin
      prompt('Upload "'+fn+'" ? ');
      if yn then begin ok:=true; close(ulff);
        nl; print('Please enter a one line description.'); prompt(':');
        inputl(f.description,60);
        if (f.description[1]='\') or (rvalidate in thisuser.ac) then culb:=0;
        if f.description[1]='\' then f.description:=copy(f.description,2,80);
        iscan(pl);
        ok:=true; ft:=255;
        if uls then receive1('dloads\'+fn,ok);
        nl; nl;
        if not ok then print('Not saved.') else begin
          f.filename:=fn;
          f.owner:=usernum;
          f.date:=date;
          f.daten:=daynum(date);
          for x:=1 to 17 do f.res[x]:=0;
          for x:=1 to 3 do f.ft[x]:=0;
          if ft<>255 then begin
            f.ft[1]:=$81; f.ft[2]:=$f5; f.ft[3]:=ft;
          end;
          assign(fi,'dloads\'+fn);
          {$I-} reset(fi); {$I+}
          if ioresult=0 then begin
            f.blocks:=trunc((longfilesize(fi)+127.0)/128.0);
            close(fi);
            for x:=pl downto 1 do begin
              seek(ulff,x); read(ulff,f1);
              seek(ulff,x+1); write(ulff,f1);
            end;
            seek(ulff,1);
            write(ulff,f);
            seek(ulff,0); read(ulff,f); f.blocks:=pl+1;
            seek(ulff,0); write(ulff,f);
            sysoplog('Uploaded "'+fn+'" on '+uboards[culb].name);
            print('File successfully uploaded.');
          end else begin
            print('Oops, system error.  Not saved.');
            sysoplog('Error uploading "'+fn+'"');
          end;
        end;
      end;
    end;
    close(ulff); culb:=ob;
  end;
  nl; nl;
end;

procedure idl;
var i:str;
begin
  helpl:='X';
  nl; print('Download -'); nl; prompt('Enter filename: '); input(i,12);
  dl(i);
  nl; nl;
end;

procedure iul;
var i:str;
begin
  helpl:='U';
  nl; nl; print('Upload -'); nl; prompt('Enter filename: '); input(i,12);
  ul(i);
  nl; nl;
end;

procedure gfn(var fn:str);
begin
  nl; helpl:='L';
  prompt('File mask: '); input(fn,12);
  if fn='' then fn:='*.*';
  fn:=align(fn);
end;

function aln(i:str; n:integer):str;
begin
  while length(i)<n do i:=' '+i;
  aln:=i;
end;

procedure pfn(f:ulfrec; var abort,next:boolean);
begin
  printacr(align(f.filename)+':'+aln(cstr(f.blocks),4)+' :'+f.description,abort,next);
end;

procedure searchb(b:integer; fn:str; var abort:boolean);
var oldboard,pl,rn:integer; f:ulfrec;
begin
  oldboard:=culb; culb:=b;
  recno(fn,pl,rn);
  while (rn<=pl) and (not abort) and (not hangup) and (rn<>0) do begin
    seek(ulff,rn); read(ulff,f);
    pbn(abort);
    pfn(f,abort,next);
    nrecno(fn,pl,rn);
  end;
  close(ulff);
  culb:=oldboard;
end;

procedure searchbd(b:integer; ts:str; var abort:boolean);
var oldboard,pl,rn:integer; f:ulfrec; next:boolean;
begin
  oldboard:=culb; culb:=b; iscan(pl);
  rn:=1;
  while (rn<=pl) and (not abort) and (not hangup) do begin
    seek(ulff,rn); read(ulff,f);
    if pos(ts,uc(f.description))<>0 then begin
      pbn(abort);
      pfn(f,abort,next);
    end;
    rn:=rn+1;
  end;
  close(ulff);
  culb:=oldboard;
end;

procedure search;
var fn:str; bn:integer; abort:boolean;
begin
  nl; nl; print('Search all directories.');
  gfn(fn);
  if cs then bn:=0 else bn:=1; abort:=false;
  while (not abort) and (bn<=maxulb) and (not hangup) do begin
    if uboards[bn].dsl<=thisuser.dsl then searchb(bn,fn,abort);
    bn:=bn+1;
  end;
end;

procedure searchd;
var fn:str; bn:integer; abort:boolean;
begin
  nl; nl; print('Find a description -'); nl;
  print('Enter what to search description for.');
  helpl:='Y';
  prompt(': '); input(fn,20);
  if fn<>'' then begin
    nl; print('Searching for "'+fn+'"'); nl;
    prompt('Search all directories? ');
    if yn then begin
      if cs then bn:=0 else bn:=1; abort:=false;
      while (not abort) and (bn<=maxulb) and (not hangup) do begin
        if uboards[bn].dsl<=thisuser.dsl then searchbd(bn,fn,abort);
        bn:=bn+1;
      end;
    end else searchbd(culb,fn,abort);
  end;
end;

procedure newfiles(b:integer; var abort:boolean);
var oldboard,pl,rn,ldn:integer; f:ulfrec; next:boolean;
begin
  oldboard:=culb; culb:=b; iscan(pl);
  ldn:=daynum(ldate);
  rn:=1;
  while (rn<=pl) and (not abort) and (not hangup) do begin
    seek(ulff,rn); read(ulff,f);
    if f.daten>=ldn then begin
      pbn(abort);
      pfn(f,abort,next);
    end;
    rn:=rn+1;
  end;
  close(ulff);
  culb:=oldboard;
end;

procedure nf;
var bn:integer; abort:boolean;
begin
  nl; print('Search for new files.'); nl;
  prompt('Search all directories? ');
  if yn then begin
    if cs then bn:=0 else bn:=1; abort:=false;
    while (not abort) and (bn<=maxulb) and (not hangup) do begin
      if uboards[bn].dsl<=thisuser.dsl then newfiles(bn,abort);
      bn:=bn+1;
    end;
  end else newfiles(culb,abort);
end;

procedure delete(rn:integer; var pl:integer);
var f:ulfrec; i:integer;
begin
  if (rn<=pl) and (rn>0) then begin
    pl:=pl-1;
    for i:=rn to pl do begin
      seek(ulff,i+1); read(ulff,f);
      seek(ulff,i); write(ulff,f);
    end;
    seek(ulff,0); f.blocks:=pl; write(ulff,f);
  end;
end;

procedure remove;
var pl,c,rn:integer; f:ulfrec; fn:str; ff:file; u:userrec; tf:boolean;
begin
  print('Enter filename to remove.'); prompt(': ');
  input(fn,12);
  if fn<>'' then begin
    recno(fn,pl,rn);
    if rn<>0 then begin
      seek(ulff,rn); read(ulff,f);
      if (usernum=f.owner) or cs then begin
        print('Filename: "'+f.filename+'"');
        print('Desc.   : '+f.description);
        print('# blocks: '+cstr(f.blocks));
        reset(uf); seek(uf,f.owner); read(uf,u); close(uf);
        print('U/L by  : '+u.name+' #'+cstr(f.owner));
        print('U/L on  : '+f.date);
        prompt('Delete this? ');
        if yn then begin
          delete(rn,pl);
          if cs then begin
            prompt('Erase file too? ');
            tf:=yn;
          end else tf:=true;
          if tf then begin
            assign(ff,'dloads\'+fn);
            {$I-} erase(ff); {$I+}
            c:=ioresult;
          end;
        end;
      end;
    end;
    close(ulff);
  end;
  nl; nl;
end;

procedure move;
var pl,c,rn,int,dbn:integer; f:ulfrec; fn:str; ff:file; i:str;
begin
  print('Enter filename to move.'); prompt(': ');
  input(fn,12);
  if fn<>'' then begin
    recno(fn,pl,rn);
    if rn<>0 then begin
      seek(ulff,rn); read(ulff,f);
      print(align(f.filename)+' : '+f.description); nl; nl;
      prompt('Move this? ');
      if yn then begin
        nl;
        for int:=0 to maxulb do
          print(cstr(int)+' : '+uboards[int].name);
        nl; nl;
        prompt('To which directory? '); input(i,3);
        dbn:=value(i); if (dbn=0) and (i<>'0') then dbn:=-1;
        if (dbn<0) or (dbn>maxulb) then print('Can''t move it there.')
        else begin
          delete(rn,pl);
          close(ulff);
          int:=culb; culb:=dbn; iscan(pl);
          seek(ulff,pl+1); write(ulff,f);
          seek(ulff,0); f.blocks:=pl+1; write(ulff,f);
          culb:=int;
        end;
      end;
    end;
    close(ulff);
  end;
end;

procedure ren;
var pl,c,rn,int,dbn:integer; f:ulfrec; fn,fd:str; ff:file; i:str;
begin
  print('Enter filename to rename.'); prompt(': ');
  input(fn,12); nl; nl;
  if fn<>'' then begin
    recno(fn,pl,rn);
    if rn<>0 then begin
      seek(ulff,rn); read(ulff,f);
      print(align(f.filename)+' : '+f.description); nl; nl;
      prompt('Rename this stuff? ');
      if yn then begin
        prompt('New filename? '); input(fn,12);
        if fn<>'' then begin
          if exist('dloads\'+fn) then print('Can''t use that filename.') else begin
            chdir('dloads'); assign(ff,f.filename); rename(ff,fn); chdir('..');
            f.filename:=fn;
          end;
        end;
        print('New description -'); prompt(': '); inputl(fd,60);
        if fd<>'' then f.description:=fd;
        seek(ulff,rn); write(ulff,f);
      end;
    end;
    close(ulff);
  end;
end;

function gtr(f,f1:ulfrec):boolean;
begin
  if sortbd and (f1.daten<>f.daten) then
    if f1.daten<f.daten then
      gtr:=false
    else
      gtr:=true
  else
    if f1.filename>f.filename then
      gtr:=false
    else
      gtr:=true;
end;

procedure sortd(c:integer);
var oldboard,trn,srn,i,i1,pl:integer; f,f1:ulfrec;
begin
  oldboard:=culb; culb:=c; iscan(pl);
  nl; print('Sorting '+uboards[culb].name);
  for i:=1 to pl-1 do begin
    seek(ulff,i); read(ulff,f); trn:=i;
    for i1:=i+1 to pl do begin
      seek(ulff,i1); read(ulff,f1);
      if gtr(f,f1) then begin
        f:=f1; trn:=i1;
      end;
    end;
    seek(ulff,i); read(ulff,f1); seek(ulff,i);
    write(ulff,f); seek(ulff,trn); write(ulff,f1);
  end;
  close(ulff);
  culb:=oldboard;
end;

procedure sort;
var bn:integer;
begin
  nl; nl; prompt('Sort by date? '); if yn then sortbd:=true else sortbd:=false;
  nl; prompt('Sort all boards? ');
  if yn then
    for bn:=0 to maxulb do
      sortd(bn)
  else
    sortd(culb);
end;

procedure listfiles;
var abort:boolean; fn:str;
begin
  nl; nl; print('List files.');
  gfn(fn); abort:=false;
  searchb(culb,fn,abort);
end;

procedure listf(n:integer; var abort:boolean);
var f:ulfrec; i,i1:str; next:boolean;
begin
  seek(ulff,n); read(ulff,f);
  i:=cstr(n); while length(i)<3 do i:=' '+i;
  i:=i+': '+align(f.filename);
  while length(i)<20 do i:=i+' ';
  i1:=cstr(f.blocks); while length(i1)<5 do i1:=' '+i1; i:=i+i1;
  i:=i+'  '+f.date+'  '; i1:=cstr(f.owner); while length(i1)<3 do i1:=' '+i1;
  i:=i+i1;
  printacr(i,abort,next);
end;

procedure browsefiles;
var pl,n,nfl,cn:integer; f:ulfrec; i,i1:str; abort,next,list,done:boolean;
begin
  iscan(pl); nl; nl; helpl:='B';
    print('('+uboards[culb].name+') - '+cstr(pl)+' files');
    if pl<>0 then begin
    nl; abort:=false; done:=false;
    prompt('Start at? '); input(i,3); cn:=value(i); if cn=0 then cn:=1;
    if i='Q' then cn:=0; if cn>pl then cn:=0;
    if cn>0 then begin list:=true;
      repeat
        tleft;
        if list then begin
          if cn>pl then cn:=1;
          nfl:=0;
          print(' NN: filename.ext   blcks  mm/dd/yy  frm');
          while (not hangup) and (nfl<10) and (not abort) and (cn<=pl) do begin
            listf(cn,abort); cn:=cn+1; nfl:=nfl+1;
          end;
          list:=false;
        end;
        nl; prompt('Browse: (1-'+cstr(pl)+',^'+cstr(cn)+'),U,D,Q,L,? :');
        input(i,3); n:=0;
        if (i='') and (cn>pl) then i:='Q';
        n:=value(i); if (n>0) and (n<=pl) then begin cn:=n; i:='D'; end;
        if i='?' then begin print('U:pload     D:ownload');
                            print('Q:uit       L:ist files'); end;
        if i='Q' then done:=true;
        if i='L' then list:=true;
        if i='U' then begin close(ulff); iul; iscan(pl); end;
        if i='D' then begin
          if n=0 then begin print('Download -'); nl; prompt('Which number? ');
            input(i1,3); n:=value(i1); end;
          if (n>0) and (n<=pl) then dl1(n);
        end;
      until done or hangup;
    end;
  end;
  close(ulff);
end;

procedure pointdate;
var i:str; n:integer;
begin
  nl; nl; nl; helpl:='P';
  print('Enter limiting date for new files -');
  print('Date is currently set to '+ldate);
  print(' mm/dd/yy');
  prompt(':'); input(i,8);
  nl; nl;
  n:=daynum(i);
  if n=0 then
    print('Illegal date.')
  else
    ldate:=i;
  nl; print('Current limiting date is '+ldate);
end;

procedure listboards;
var b:integer; i:str; abort,next:boolean;
begin
  nl;nl; print('Directories available to you:'); nl; nl;
  b:=1; abort:=false;
  while (b<=maxulb) and (not abort) and (not hangup) do begin
    if uboards[b].dsl<=thisuser.dsl then begin
       i:=cstr(b);
       if length(i)=1 then i:=' '+i;
       i:=i+' : '+uboards[b].name;
       printacr(i,abort,next);
    end;
    b:=b+1;
  end;
  nl;nl;
end;

procedure mmkey(var i:str);
var c:char;
begin
  repeat
    repeat
      getkey(c);
      if c=#26 then phelp;
      skey(c);
    until (((c>=' ') and (c<chr(127))) or (c=chr(13))) or hangup;
    c:=upcase(c);
    outkey(c);
    thisline:=thisline+c;
    if (c='/') or (c='1') then begin
      i:=c;
      repeat
        getkey(c);
        if c=#26 then phelp;
        skey(c);
      until ((c>=' ')and(c<=chr(127))) or (c=chr(13)) or (c=chr(8)) or hangup;
      c:=upcase(c);
      if c<>chr(13) then begin outkey(c); thisline:=thisline+c; end;
      if (c=chr(8)) or (c=chr(127)) then prompt(' '+c);
      if c='/' then input(i,20) else if c<>chr(13) then i:=i+c;
    end else i:=c;
  until (c<>chr(8)) and (c<>chr(127)) or hangup;
  nl;
end;

procedure reqchat;
begin
  nl;nl; if (not sysop) or (rchat in thisuser.ac)
  then begin
    print('Sysop not available.');
  end else begin
    if not chatcall then begin
      helpl:='C'; prompt('Reason: '); inputl(i,70);
      if i<>'' then begin
        sysoplog('Chat: '+i);
        print('Chat call now on.');
        sound(440); delay(500); nosound;
        chatr:=i; chatcall:=true;
      end else chatr:='';
    end else
      begin chatcall:=false; print('Chat call turned off.'); chatr:='';end;
  end;
  nl;nl; topscr;
end;

procedure yourinfo;
begin
  nl; nl;
  print('Your name : '+nam);
  print('Your SL   : '+cstr(thisuser.sl));
  print('Your DSL  : '+cstr(thisuser.dsl));
  print('You D/L''d : '+cstr(thisuser.dk)+'K in '+cstr(thisuser.downloads)+' files');
  print('You U/L''d : '+cstr(thisuser.uk)+'K in '+cstr(thisuser.uploads)+' files');
end;

procedure ftmainmenu;
var ii,i:str; int,inte:integer; rl:real;
begin
  dump; tleft; nl; nl;
  rl:=(seclev[thisuser.sl].ttime*60.0+extratime+timeon-timer);
  if rl>32767.0 then rl:=32000; if rl<0.0 then rl:=0;
  inte:=trunc(rl);
  i:=cstr(inte div 3600)+':'; ii:=cstr((inte mod 3600) div 60);
  if length(ii)=1 then ii:='0'+ii; i:='T - '+i+ii+':';
  ii:=cstr(inte mod 60); if length(ii)=1 then ii:='0'+ii;
  i:=i+ii; print(i);
  i:='('+cstr(culb)+')-('+uboards[culb].name+')  :';
  prompt(i);
  helpl:='T';
  mmkey(i);
  helpl:=#0;
  if length(i)=1 then case i[1] of
    '?':printfile('gfiles\dlmenu.msg');
    'Q':doneft:=true;
    'B':browsefiles;
    'U':iul;
    'D':idl;
    'L':listfiles;
    'S':search;
    'F':searchd;
    'C':reqchat;
    'O':begin
          nl;nl;prompt('Hangup?  Sure? '); helpl:='O';
          if yn then begin
            cls;
            printfile('gfiles\logoff.msg');
            hangup:=true;
            hungup:=false;
          end;
        end;
    '*':listboards;
    'P':pointdate;
    'N':nf;
    'R':remove;
    'M':if cs then move;
    'V':lfii;
    'Y':yourinfo;
  end;
  if i='/O' then hangup:=true;
  if (i='SORT') and cs then sort;
  if (i='REN') and cs then ren;
  if (i='0') and cs then culb:=0;
  int:=value(i); if (int>0) and (int<=maxulb) then
    if thisuser.dsl>=uboards[int].dsl then
      if (uboards[int].password='') or cs then culb:=int else begin
        prompt('Password? '); input(i,10);
        if i<>uboards[int].password then
          print('Wrong.')
        else
          culb:=int;
       end;
end;

begin
  iport; i1; doneft:=false;
  while (not doneft) and (not hangup) do
    ftmainmenu;
  ret:=200;
  return;
end.